Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/PNL Libraries/TCPStuff.p

Text File | 1994-10-03 | 35.1 KB | 1,247 lines | [TEXT/PJMM]

unit TCPStuff;

{ TCPStuff © Peter Lewis, Oct 1991 }
{ This source is Freeware }

interface

    uses
        TCPTypes;

    const
        Minimum_TCPBufferSize = 4096;
        Default_TCPBufferSize = longInt(6) * 1024;
        Maximum_TCPBufferSize = 30000;
    { Amount of space to allocate for each TCP connection }
        INCOMINGBUFSIZE = 100;    { Incoming buffer size, used for buffering ReceiveUpTo. }
        control_block_max = 260;
        tooManyControlBlocks = -23098;
        Default_UDPBufferSize = 4096;

    type
        OSErrPtr = ^OSErr;

{ TCP connection description: }
        TCPConnectionType = record
                magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
                stream: StreamPtr;
                closedone: boolean;
                laststate: integer;
                asends, asendcompletes: longInt;
                closeuserptr: OSErrPtr;
                incomingPtr: Ptr;                                { Pointer into inBuf of next byte to read. }
                incomingSize: longInt;                        { Number of bytes left in inBuf. }
                buffer: ptr;        { connection buffer. }
                inBuf: array[1..INCOMINGBUFSIZE] of SignedByte;    {Input buffer. }
            end;
        TCPConnectionPtr = ^TCPConnectionType;

        MyControlBlock = record
                tcp: TCPControlBlock;
                inuse: boolean;
                userptr: OSErrPtr;
                proc: procPtr;
                tcpc: TCPConnectionPtr;
            end;
        MyControlBlockPtr = ^MyControlBlock;

        TCPXControlBlock = record
                completion: ProcPtr;
                pb: TCPControlBlock;
            end;
        TCPXControlBlockPtr = ^TCPXControlBlock;

        TCPStateType = (T_WaitingForOpen, T_Closed, T_Listening, T_Opening, T_Established,{}
            T_Closing, T_PleaseClose, T_Unknown);

    type
        UDPConnectionRecord = record
                magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
                stream: StreamPtr;
                outstanding: integer;
            end;
        UDPConnectionPtr = ^UDPConnectionRecord;

    type
        DNRCompletionProcPtr = ProcPtr;
{ procedure DNRCompletionProc(drp:DNRRecordPtr); }
        DNRRecord = record
{ Generally you only need to look at the first three of these }
                ioResult: OSErr;
                name: Str255;
                addr: longInt;
                completion: DNRCompletionProcPtr;
                case integer of
                    1: (
                            hi: hostInfo;
                    );
                    2: (
                            hmx: hmxInfoRec;
                    );
                    3: (
                            cacherec: cacheEntryRecord;
                    );
            end;
        DNRRecordPtr = ^DNRRecord;

    var
        icmp_sent_out, icmp_got_back: longInt;

    function C2PStr (s: stringPtr): stringPtr;
    procedure SanitizeHostName (var s: str255);

    function TCPInit: OSErr;
    procedure TCPFinish;

    function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
    function TCPFlush (connection: TCPConnectionptr): OSErr;
    function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
    function TCPAbort (connection: TCPConnectionPtr): OSErr;
    function TCPRelease (var connection: TCPConnectionPtr): OSErr;
    procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
    function TCPState (connection: TCPConnectionPtr): TCPStateType;
    function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
    function TCPLocalPort (connection: TCPConnectionPtr): integer;
    function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
{ Use EITHER RawReceive, or the other Receives.  Don't combine them for one stream! }
    function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
    function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
    function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
                                    charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
                                    var gottermchar: boolean): OSErr;
    function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
    function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;

    function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longInt; var localport: integer): OSErr;
    function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longInt; var remoteport: integer;{}
                                    var datap: ptr; var datalen: integer): OSErr;
    function UDPReturnBuffer (connection: UDPConnectionPtr; datap: ptr): OSErr;
    function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
    function UDPWrite (connection: UDPConnectionPtr; remoteIP: longInt; remoteport: integer;{}
                                    datap: ptr; datalen: integer; checksum: boolean): OSErr;
    function UDPRelease (var connection: UDPConnectionPtr): OSErr;
    function UDPMTU (remoteIP: longInt; var mtu: integer): OSErr;

    function IPGetMyIPAddr (var myIP: longInt): OSErr;
    function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: ptr; datalen: integer; complete: ProcPtr; userdata: univ ptr; extradata: univ ptr): OSErr;
{procedure ICMPCompletion (cbp: IPControlBlockPtr; userdata: ptr;extradata:ptr);}

    procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
    procedure DNRAddrToName (addr: longInt; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);

    procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
    procedure UDPZeroCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
    procedure TCPControlAsync (pbp: TCPControlBlockPtr; comp: ProcPtr);
{ pbp MUST be a ptr to an XTCPControlBlock }

implementation

    uses
{$IFC undefined THINK_Pascal}
        Memory, Errors, Devices, Events,
{$ENDC}
        DNR;

    const
        MAGICNUMBER = 'TMGK';    { Unique value used to trap illegal connection IDs. }
        UDPMagic = 'UDPM';
        UDPBad = '????';
        dispose_block_max = 100;

    type
        MyControlBlockArray = array[1..control_block_max] of MyControlBlockPtr;

    type
        stackframe = packed record
                frameptr: ptr;
                returnptr: ptr;
                paramblockptr: ptr;
            end;
        stackframeptr = ^stackframe;

    var
        driver_refnum: integer;
        controlblocks: MyControlBlockArray;
        disposeblocks: array[1..dispose_block_max] of ptr;

    const
        max_ICMPDataArray = 100;
    type
        ICMPData = record
                complete: ProcPtr;
                userdata: ptr;
                extradata: ptr;
            end;
        ICMPDataArray = array[1..max_ICMPDataArray] of ICMPData;
    var
        icmp_data_array: ICMPDataArray;

{$PUSH}
{$D-}
{$R-}
    procedure SanitizeHostName (var s: str255);
        var
            dummysp: stringPtr;
    begin
        dummysp := C2PStr(@s);
        if s[Length(s)] = '.' then
            s[0] := chr(Length(s) - 1);
    end;
{$POP}

    function GetStackFrame: stackframeptr;
    inline
        $2E8E;

    procedure CallIOCompletion (cbp: MyControlBlockPtr; addr: procPtr);
    inline
        $205F, $4E90;

    procedure CallTCPCompletion (cbp: TCPControlBlockPtr; addr: procPtr);
    inline
        $205F, $4E90;

{$PUSH}
{$D-}

    procedure TCPPreCompletion; { All C functions look like pascal paramterless procedures from the procs point of view }
        var
            prp: TCPXControlBlockPtr;
            pbp: TCPControlBlockPtr;
    begin
        pbp := TCPControlBlockPtr(GetStackFrame^.paramblockptr);
        prp := TCPXControlBlockPtr(ord(pbp) - 4);
        if prp^.completion <> nil then begin
            CallTCPCompletion(pbp, prp^.completion);
        end;
    end;

    procedure TCPControlAsync (pbp: TCPControlBlockPtr; comp: ProcPtr);
        var
            err: OSErr;
            prp: TCPXControlBlockPtr;
    begin
        prp := TCPXControlBlockPtr(ord(pbp) - 4);
        prp^.completion := comp;
        pbp^.ioCompletion := @TCPPreCompletion;
        err := PBControlAsync(ParmBlkPtr(pbp));
        if err <> noErr then begin
            pbp^.ioResult := err;
            if prp^.completion <> nil then begin
                CallTCPCompletion(pbp, prp^.completion);
            end;
        end;
    end;

    procedure IOCompletionPascal (cbp: MyControlBlockPtr);
    begin
        with cbp^ do begin
            if userptr <> nil then begin
                userptr^ := cbp^.tcp.ioResult;
            end;
            inuse := false;
            if proc <> nil then begin
                CallIOCompletion(cbp, proc);
            end;
        end;
    end;

{$IFC undefined THINK_Pascal}

    procedure IOCompletion;
        asm;
    begin
        move.l 4 (sp), a0
        move.l a0,-(sp)
        jsr IOCompletionPascal
        rts
{        move.l 4 (sp), a0}
{        move.l a0,-(sp)}
{        jsr IOCompletionPascal}
{        rts}
    end;

{$ELSEC}

    procedure IOCompletion; { All C functions look like pascal paramterless procedures from the procs point of view }
    begin
        IOCompletionPascal(MyControlBlockPtr(GetStackFrame^.paramblockptr));
    end;

{$ENDC}

    procedure ZotBlocks;
        var
            i: integer;
    begin
        for i := 1 to dispose_block_max do begin
            if disposeblocks[i] <> nil then begin
                DisposePtr(disposeblocks[i]);
                disposeblocks[i] := nil;
            end;
        end;
    end;

    procedure AddBlock (p: univ ptr);
{ Called at interupt level }
{ Must work even while ZotBlocks is in progress }
        var
            i: integer;
    begin
        for i := 1 to dispose_block_max do begin
            if disposeblocks[i] = nil then begin
                disposeblocks[i] := p;
                leave;
            end;
        end;
    end;

    procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
    { Zero out the control block parameters. }
        var
            i: integer;
            p: longInt;
    begin
        for p := longInt(@cb) to longInt(@cb) + SizeOf(TCPControlBlock) - 1 do
            ptr(p)^ := 0;
        cb.tcpStream := stream;
        cb.ioCRefNum := driver_refnum;
        cb.csCode := call;
    end;

    function GetCB (var cbp: MyControlBlockPtr; tcpc: TCPConnectionPtr; call: integer; userptr: OSErrPtr; proc: procptr): OSErr;
{ NOTE: Must not move memory if there is a free block available (ie, during a Completion call) }
        var
            i: integer;
    begin
        i := 1;
        while (i < control_block_max) & (controlblocks[i] <> nil) & controlblocks[i]^.inuse do
            i := i + 1;
        cbp := controlblocks[i];
        if cbp = nil then begin
            cbp := MyControlBlockPtr(NewPtr(SizeOf(MyControlBlock)));
            if cbp <> nil then begin
                cbp^.inuse := false;
                controlblocks[i] := cbp;
            end;
        end;
        if (cbp <> nil) & not cbp^.inuse then begin
            ZeroCB(cbp^.tcp, tcpc^.stream, call);
            cbp^.tcp.ioCompletion := @IOCompletion;
            cbp^.inuse := true;
            cbp^.userptr := userptr;
            cbp^.tcpc := tcpc;
            cbp^.proc := proc;
            if userptr <> nil then
                userptr^ := inprogress;
            GetCB := noErr;
        end
        else begin
            cbp := nil;
            GetCB := memFullErr;
        end;
    end;

    procedure FreeCB (var cbp: MyControlBlockPtr);
    begin
        if cbp <> nil then
            cbp^.inuse := false;
        cbp := nil;
    end;
{$POP}

{$S Init}
    function TCPInit: OSErr;
        var
            oe: OSErr;
            i: integer;
    begin
        oe := OpenDriver('.IPP', driver_refnum);
        for i := 1 to control_block_max do
            controlblocks[i] := nil;
        for i := 1 to max_ICMPDataArray do
            icmp_data_array[i].complete := nil;
        TCPInit := oe;
    end;

{$S Term}
    procedure TCPFinish;
        var
            i: integer;
    begin
        for i := 1 to control_block_max do
            if controlblocks[i] <> nil then begin
                DisposPtr(ptr(controlblocks[i]));
                controlblocks[i] := nil;
            end;
    end;

{$S}
    procedure DestroyConnection (var connection: TCPConnectionPtr);
    begin
        connection^.magic := '????';
        if connection^.buffer <> nil then
            DisposPtr(ptr(connection^.buffer));
        DisposPtr(Ptr(connection));
        connection := nil;
    end;

    function ValidateConnection (connection: TCPConnectionPtr): OSErr;
    begin
        if (connection = nil) | (connection^.magic <> MAGICNUMBER) then begin
            ValidateConnection := connectionDoesntExistErr;
        end
        else begin
            ValidateConnection := noErr;
        end;
    end;

{$PUSH}
{$D-}
    function MyPBControlAsync (var cbp: MyControlBlockPtr): OSErr;
        var
            oe: OSErr;
    begin
        oe := PBControlAsync(ParmBlkPtr(cbp));
        if oe <> noErr then begin
            FreeCB(cbp);
        end;
        MyPBControlAsync := oe;
    end;
{$POP}

    procedure SetUserPtr (userptr: OSErrPtr; oe: OSErr);
    begin
        if userptr <> nil then begin
            if oe <> noErr then
                userptr^ := oe;
        end;
    end;

    function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
        var
            oe: OSErr;
    begin
        connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
        if connection = nil then
            oe := memFullErr
        else begin
            oe := noErr;
            with connection^ do begin
                buffer := nil;
                magic := MAGICNUMBER;
                asends := 0;
                asendcompletes := 0;
                closedone := false;
                incomingSize := 0;
                stream := strm;
            end;
        end;
        if (oe <> noErr) and (connection <> nil) then
            DestroyConnection(connection);
        TCPCreateConnectionForStream := oe;
    end;

    function CreateStream (var connection: TCPConnectionPtr; buffersize: longInt): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        if buffersize = 0 then
            buffersize := Default_TCPBufferSize;
        connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
        if connection = nil then
            oe := memFullErr
        else
            with connection^ do begin
                buffer := NewPtr(buffersize);
                if buffer = nil then begin
                    oe := memFullErr;
                    DisposPtr(ptr(connection));
                    connection := nil;
                end
                else begin
                    magic := MAGICNUMBER;
                    asends := 0;
                    asendcompletes := 0;
                    closedone := false;
                    incomingSize := 0;
                    ZotBlocks;
                    ZeroCB(cb, nil, TCPcsCreate);
                    cb.create.rcvBuff := buffer;
                    cb.create.rcvBuffLen := buffersize;
                    oe := PBControlSync(@cb);
                    stream := cb.tcpStream;
                end;
            end;
        if (oe <> noErr) and (connection <> nil) then
            DestroyConnection(connection);
        CreateStream := oe;
    end;

    function PAOpen (var connection: TCPConnectionPtr; cs: integer; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
        var
            oe, ooe: OSErr;
            cbp: MyControlBlockPtr;
            cb: TCPControlBlock;
    begin
        oe := CreateStream(connection, buffersize);
        if oe = noErr then begin
            with connection^ do begin
                ZotBlocks;
                oe := GetCB(cbp, connection, cs, userptr, nil);
                if oe = noErr then begin
                    cbp^.tcp.open.localPort := localPort;
                    cbp^.tcp.open.remoteHost := remoteIP;
                    cbp^.tcp.open.remotePort := remoteport;
                    cbp^.tcp.open.ulpTimeoutAction := -1;
                    oe := MyPBControlAsync(cbp);
                end;
                if oe <> noErr then begin
                    ZeroCB(cb, stream, TCPcsRelease);
                    ooe := PBControlSync(@cb);
                    DestroyConnection(connection);
                end;
            end;
        end;
        SetUserPtr(userptr, oe);
        PAOpen := oe;
    end;

{ Open a connection to another machine }
    function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    begin
        TCPActiveOpen := PAOpen(connection, TCPcsActiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
    end;

{ Open a socket on this machine, to wait for a connection }
    function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
    begin
        TCPPassiveOpen := PAOpen(connection, TCPcsPassiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
    end;

    function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
{ Return readCount characters from the TCP connection. }
{ WARNING: Doesnt handle incoming buffer, so don't use with TCPReceiveUptp or ReadByte }
        var
            cb: TCPControlBlock;
            oe: OSErr;
    begin
        oe := noErr;
        while (oe = noErr) & (readCount > 0) do begin
            ZotBlocks;
            ZeroCB(cb, connection^.stream, TCPcsRcv);
            cb.receive.rcvBuff := returnPtr;
            cb.receive.rcvBuffLength := readCount;
            oe := PBControlSync(@cb);
            longInt(returnPtr) := longInt(returnPtr) + cb.receive.rcvBuffLength;
            readCount := readCount - cb.receive.rcvBuffLength;
        end;
        TCPRawReceiveChars := oe;
    end;

{ Return readCount characters from the TCP connection.}
    function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
        var
            readCountStr: Str255;
            l: longInt;
            p: Ptr;
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            if readCount < 0 then begin
                oe := invalidLengthErr;
            end
            else if readCount > 0 then begin
                p := returnPtr;
                with connection^ do
                    if incomingSize > 0 then begin
            { Read as much as there is or as much as we need, whichever is less. }
                        if readCount < incomingSize then
                            l := readCount
                        else
                            l := incomingSize;
                        BlockMove(incomingPtr, p, l);
                        incomingPtr := Ptr(ord4(incomingPtr) + l);
                        incomingSize := incomingSize - l;
                        p := Ptr(ord4(p) + l);
                        readCount := readCount - l;
                    end;
                { If there's more needed, then read it from the connection. }
                if readCount > 0 then begin
                        { Issue a read and wait until it all arrives). }
                    oe := TCPRawReceiveChars(connection, p, readCount);
                end;
            end;
        TCPReceiveChars := oe;
    end;

    function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
        { Return the next byte in the buffer, reading more in if necessary. }
        var
            waitUntil: longInt;
            readIn: longInt;
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            with connection^ do begin            { Check if we need to read in more bytes. }
                if incomingSize = 0 then begin
                    if (timeout = 0) and (TCPCharsAvailable(connection) = 0) then begin
                        oe := commandTimeoutErr;
                    end
                    else begin
                        waitUntil := TickCount + timeout;
    { keep on trying to read until we get at least one, or the time-out happens. }
                        while (oe = noErr) and (incomingSize = 0) do begin                { Get the status. }
                            readIn := TCPCharsAvailable(connection);    { If there's something there to read, do so. }
                            if readIn > 0 then begin    { Don't read any more than will fit in the buffer. }
                                if readIn > INCOMINGBUFSIZE then
                                    readIn := INCOMINGBUFSIZE;
                        { Issue the read. }
                                oe := TCPRawReceiveChars(connection, @inBuf, readIn);
                                if oe = noErr then begin
                                    incomingSize := readIn;
                                    incomingPtr := @inBuf;
                                end;
                            end        { If not, do another round or get out, depending on the timeout condition. }
                            else if TickCount > waitUntil then begin
                                oe := commandTimeOutErr;
                            end;
                        end;
                    end;
                end;
                { Get the byte to return. }
                if incomingSize > 0 then begin
                    b := incomingPtr^;
                    incomingPtr := Ptr(ord4(incomingPtr) + 1);
                    incomingSize := incomingSize - 1;
                end
                else
                    b := 0;
            end;
        TCPReadByte := oe;
    end;

{ Pass in a block of memory (readPtr,readSize), already containing readPos bytes}
{ TCPReceiveUpTo will then read characters until a termChar character is reached,}
{ or until waitForChars ticks go by without receiving any bytes.  If waitForChars is}
{ zero, then TCPReceiveUpTo will return immediately.  If termChar=0, then it}
{ will read the entire buffer, and any characters that arrive before a timeout }
    function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
                                    charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
                                    var gottermchar: boolean): OSErr;
        var
            oe: OSErr;
            inChar: SignedByte;
            p: Ptr;
    begin
        oe := ValidateConnection(connection);
        gottermchar := false;
        if oe = noErr then begin
{ Cycle until the timeout happens or we see the termintor character or we run out of room. }
            while (oe = noErr) and (readPos < readSize) and not gottermchar do begin            { Get the next character. }
                oe := TCPReadByte(connection, charTimeOut, inChar);                    { Ignore the character if it's a zero. }
                if (oe = noErr) and (inChar <> 0) then begin            { Put it in the result. }
                    p := Ptr(ord4(readPtr) + readPos);
                    p^ := inChar;
                    readPos := readPos + 1;
                    gottermchar := inChar = termChar;
                end;
            end;
            if oe = commandTimeOutErr then
                oe := noErr;
        end;
        TCPReceiveUpTo := oe;
    end;

    function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
        var
            wds: wdsType;
            oe: OSErr;
            cb: TCPControlBlock;
            p: ptr;
    begin
        oe := ValidateConnection(connection);
        if oe = nOErr then
            if writeCount > 0 then begin
                wds.buffer := writePtr;
                wds.size := writeCount;
                wds.term := 0;
                ZotBlocks;
                ZeroCB(cb, connection^.stream, TCPcsSend);
                cb.send.wds := @wds;
                cb.send.pushFlag := ord(push);
                oe := PBControlSync(@cb);
            end
            else if writeCount < 0 then
                oe := InvalidLengthErr;
        TCPSend := oe;
    end;

{$PUSH}
{$D-}
    procedure TCPSendComplete (cbp: MyControlBlockPtr);
        var
            oe: OSErr;
    begin
        AddBlock(cbp^.tcp.send.wds);
        with cbp^.tcpc^ do begin
            asendcompletes := asendcompletes + 1;
            if (asendcompletes = asends) and closedone then begin
                oe := GetCB(cbp, cbp^.tcpc, TCPcsClose, closeuserptr, nil);
{ GetCB won't NewPtr because the completion has just released a block }
                if oe = noErr then begin
                    oe := MyPBControlAsync(cbp);
                end;
            end;
        end;
    end;
{$POP}

    function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;
        type
            myblock = record
                    wds: wdsType;
                    data: array[0..100] of byte;
                end;
            myblockptr = ^myblock;
        var
            oe: OSErr;
            cbp: MyControlBlockPtr;
            p: myblockptr;
    begin
        oe := ValidateConnection(connection);
        if oe = nOErr then
            if writeCount > 0 then begin
                p := myblockptr(NewPtr(writeCount + SizeOf(wdsType)));
                if p = nil then
                    oe := memFullErr
                else begin
                    p^.wds.buffer := @p^.data;
                    p^.wds.size := writeCount;
                    p^.wds.term := 0;
                    with p^.wds do
                        BlockMove(writePtr, buffer, size);
                    oe := GetCB(cbp, connection, TCPcsSend, userptr, @TCPSendComplete);
                    cbp^.tcp.send.wds := POINTER(p);
                    cbp^.tcp.send.pushFlag := ord(push);
                    with connection^ do
                        asends := asends + 1;
                    oe := MyPBControlAsync(cbp);
                    if oe <> noErr then
                        DisposPtr(ptr(p));
                end;
            end
            else if writeCount < 0 then
                oe := InvalidLengthErr;
        TCPSendAsync := oe;
    end;

    function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
        var
            oe: OSErr;
            cbp: MyControlBlockPtr;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then
            with connection^ do begin
                closeuserptr := userptr;
                if userptr <> nil then
                    userptr^ := inProgress;
                closedone := true;
                if asends = asendcompletes then begin
                    ZotBlocks;
                    oe := GetCB(cbp, connection, TCPcsClose, userptr, nil);
                    if oe = noErr then begin
                        oe := MyPBControlAsync(cbp);
                    end;
                end;
            end;
        SetUserPtr(userptr, oe);
        TCPClose := oe;
    end;

    function TCPAbort (connection: TCPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            ZotBlocks;
            ZeroCB(cb, connection^.stream, TCPcsAbort);
            oe := PBControlSync(@cb);
        end;
        TCPAbort := oe;
    end;

{ Release the TCP stream, including the buffer.}
    function TCPRelease (var connection: TCPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: TCPControlBlock;
    begin
        oe := noErr;
        oe := ValidateConnection(connection);
        if oe = noErr then begin
            ZotBlocks;
            ZeroCB(cb, connection^.stream, TCPcsRelease);
            oe := PBControlSync(@cb);
            DestroyConnection(connection);
        end;
        TCPRelease := oe;
    end;

{    TCPRawState(connectionID) -- Return the state of the TCP connection.}
    procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
        var
            cb: TCPControlBlock;
            oe: OSErr;
    begin
        localhost := 0;
        localport := 0;
        remotehost := 0;
        remoteport := 0;
        available := 0;

        oe := ValidateConnection(connection);
        if oe <> noErr then begin
            state := 99; { Error -> Closed }
        end
        else begin
            ZotBlocks;
            ZeroCB(cb, connection^.stream, TCPcsStatus);
            if PBControlSync(@cb) <> noErr then begin
                state := 99; { Closed }
            end
            else begin
                state := cb.status.connectionState;
                connection^.laststate := state;
                localhost := cb.status.localhost;
                localport := cb.status.localport;
                remotehost := cb.status.remotehost;
                remoteport := cb.status.remoteport;
                available := cb.status.amtUnreadData + connection^.incomingSize;
            end;
        end;
    end;

{ Return the state of the TCP connection.}
    function TCPState (connection: TCPConnectionPtr): TCPStateType;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        case state of
            0:
                TCPState := T_Closed;
            2:
                TCPState := T_Listening;
            4, 6:
                TCPState := T_Opening;
            8:
                TCPState := T_Established;
            10, 12, 16, 18, 20:
                TCPState := T_Closing;
            14:
                TCPState := T_PleaseClose;
            98:
                TCPState := T_WaitingForOpen;
            99:
                TCPState := T_Closed;
            otherwise
                TCPState := T_Unknown;
        end;
    end;

{    Return the number of characters available for reading from the TCP connection.}
    function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        TCPCharsAvailable := available;
    end;

    function TCPLocalPort (connection: TCPConnectionPtr): integer;
        var
            state: integer;
            localhost: longInt;
            localport: integer;
            remotehost: longInt;
            remoteport: integer;
            available: longInt;
    begin
        TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
        TCPLocalPort := localport;
    end;

    function TCPFlush (connection: TCPConnectionptr): OSErr;
        var
            buffer: array[0..255] of signedByte;
            f: longInt;
            oe: OSErr;
    begin
        f := TCPCharsAvailable(connection);
        oe := noErr;
        while (f > 0) and (oe = noErr) do begin
            if f > 256 then
                f := 256;
            oe := TCPReceiveChars(connection, @buffer, f);
            if oe = noErr then
                f := TCPCharsAvailable(connection);
        end;
        TCPFlush := oe;
    end;

    procedure UDPZeroCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
    { Zero out the control block parameters. }
        var
            i: integer;
            p: longInt;
    begin
        for p := longInt(@cb) to longInt(@cb) + SizeOf(UDPControlBlock) - 1 do
            ptr(p)^ := 0;
        cb.udpStream := stream;
        cb.ioCRefNum := driver_refnum;
        cb.csCode := call;
    end;

    procedure MyNotify (stream: streamPtr; eventCode: integer; connection: UDPConnectionPtr; icmpMsg: ptr);
    begin
        if eventCode = UDPDataArrival then
            if connection^.magic = UDPMagic then
                connection^.outstanding := connection^.outstanding + 1;
    end;

    function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longInt; var localport: integer): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        if buffer_size = 0 then
            buffer_size := Default_UDPBufferSize;
        connection := UDPConnectionPtr(NewPtr(SizeOf(UDPConnectionRecord) + buffer_size));
        oe := MemError;
        if connection <> nil then begin
            connection^.magic := UDPMagic;
            UDPZeroCB(cb, nil, UDPcsCreate);
            cb.create.rcvBuff := ptr(longInt(connection) + SizeOf(UDPConnectionRecord));
            cb.create.rcvBuffLen := buffer_size;
            cb.create.notifyProc := @MyNotify;
            cb.create.userDataPtr := ptr(connection);
            cb.create.localport := localport;
            oe := PBControlSync(@cb);
            localport := cb.create.localport;
            connection^.stream := cb.udpStream;
            connection^.outstanding := 0;
        end;
        UDPCreate := oe;
    end;

    function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longInt; var remoteport: integer;{}
                                    var datap: ptr; var datalen: integer): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsRead);
        cb.receive.timeout := timeout;
        oe := PBControlSync(@cb);
        if oe = noErr then
            connection^.outstanding := connection^.outstanding - 1;
        remoteIP := cb.receive.remoteIP;
        remoteport := cb.receive.remoteport;
        datap := cb.receive.rcvBuff;
        datalen := cb.receive.rcvBuffLen;
        UDPRead := oe;
    end;

    function UDPReturnBuffer (connection: UDPConnectionPtr; datap: ptr): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsBfrReturn);
        cb.return.rcvBuff := datap;
        oe := PBControlSync(@cb);
        UDPReturnBuffer := oe;
    end;

    function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
    begin
        UDPDatagramsAvailable := connection^.outstanding;
    end;

    function UDPWrite (connection: UDPConnectionPtr; remoteIP: longInt; remoteport: integer;{}
                                    datap: ptr; datalen: integer; checksum: boolean): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
            wds: wdsType;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsWrite);
        cb.send.remoteIP := remoteIP;
        cb.send.remotePort := remoteport;
        wds.size := datalen;
        wds.buffer := datap;
        wds.term := 0;
        cb.send.wds := @wds;
        cb.send.checksum := ord(checksum);
        oe := PBControlSync(@cb);
        UDPWrite := oe;
    end;

    function UDPRelease (var connection: UDPConnectionPtr): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, connection^.stream, UDPcsRelease);
        oe := PBControlSync(@cb);
        connection^.magic := UDPBad;
        DisposPtr(ptr(connection));
        UDPRelease := oe;
    end;

    function UDPMTU (remoteIP: longInt; var mtu: integer): OSErr;
        var
            oe: OSErr;
            cb: UDPControlBlock;
    begin
        UDPZeroCB(cb, nil, UDPcsMaxMTUSize);
        cb.mtu.remoteIP := remoteIP;
        oe := PBControlSync(@cb);
        mtu := cb.mtu.mtuSize;
        UDPMTU := oe;
    end;

    procedure IPZeroCB (var cb: IPControlBlock; call: integer);
    { Zero out the control block parameters. }
        var
            i: integer;
            p: longInt;
    begin
        for p := longInt(@cb) to longInt(@cb) + SizeOf(cb) - 1 do
            ptr(p)^ := 0;
        cb.ioCRefNum := driver_refnum;
        cb.csCode := call;
    end;

    procedure IPCallCompletion (cbp: IPControlBlockPtr; userdata, extradata: ptr; addr: procPtr);
    inline
        $205F, $4E90;

{$PUSH}
{$D-}
    procedure IPICMPCompletionPascal (cbp: IPControlBlockPtr);
        var
            index: integer;
    begin
        icmp_got_back := icmp_got_back + 1;
        with cbp^.echoinfo do begin
            index := ord(userDataPtr);
            if (index > 0) & (icmp_data_array[index].complete <> nil) then begin
                IPCallCompletion(cbp, icmp_data_array[index].userdata, icmp_data_array[index].extradata, icmp_data_array[index].complete);
                icmp_data_array[index].complete := nil;
            end;
        end;
    end;

{$IFC undefined THINK_Pascal}

    procedure IPICMPCompletion;
        asm;
    begin
        move.l 4 (sp), a0
        move.l a0,-(sp)
        jsr IPICMPCompletionPascal
        rts
{        move.l 4 (sp), a0}
{        move.l a0,-(sp)}
{        jsr IPICMPCompletionPascal}
{        rts}
    end;

{$ELSEC}

    procedure IPICMPCompletion;
    begin
        IPICMPCompletionPascal(IPControlBlockPtr(GetStackFrame^.paramblockptr));
    end;

{$ENDC}


{$POP}

    function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: ptr; datalen: integer; complete: ProcPtr; userdata: univ ptr; extradata: univ ptr): OSErr;
        var
            cb: IPControlBlock;
            i, index: integer;
            oe: OSErr;
    begin
        index := -1;
        if complete <> nil then begin
            for i := 1 to max_ICMPDataArray do begin
                if icmp_data_array[i].complete = nil then begin
                    index := i;
                    icmp_data_array[i].complete := complete;
                    icmp_data_array[i].userdata := userdata;
                    icmp_data_array[i].extradata := extradata;
                    leave;
                end;
            end;
        end;
        IPZeroCB(cb, TCPcsEchoICMP);
        cb.echo.dest := remotehost;
        cb.echo.data.buffer := datap;
        cb.echo.data.size := datalen;
        cb.echo.timeout := timeout;
        cb.echo.options := nil;
        cb.echo.optlength := 0;
        cb.echo.icmpCompletion := @IPICMPCompletion;
        cb.echo.userDataPtr := ptr(ord(index)); { Avoid tickling MW bug }
        oe := PBControlSync(@cb);
        if oe = noErr then
            icmp_sent_out := icmp_sent_out + 1;
        IPSendICMPEcho := oe;
    end;

    function IPGetMyIPAddr (var myIP: longInt): OSErr;
        var
            cb: IPControlBlock;
            oe: OSErr;
    begin
        IPZeroCB(cb, TCPcsGetMyIP);
        oe := PBControlSync(@cb);
        myIP := cb.getmyip.ourAddress;
        IPGetMyIPAddr := oe;
    end;

    procedure CallDNRCompletion (drp: DNRRecordPtr; proc: ProcPtr);
    inline
        $205F, $4E90;

{$PUSH}
{$D-}
    procedure DNRNameToAddrCompletionProc (hip: hostInfoPtr; drp: DNRRecordPtr);
    begin
        drp^.ioResult := hip^.rtnCode;
        drp^.addr := drp^.hi.addrs[1];
        if drp^.completion <> nil then begin
            CallDNRCompletion(drp, drp^.completion);
        end;
    end;
{$POP}

    procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
        var
            err: OSErr;
    begin
        drp^.ioResult := 1;
        drp^.name := name;
        drp^.completion := completion;
        err := StrToAddr(name, drp^.hi, @DNRNameToAddrCompletionProc, ptr(drp));
        if err <> cacheFaultErr then begin
            drp^.hi.rtnCode := err;
            DNRNameToAddrCompletionProc(@drp^.hi, drp);
        end;
    end;

{$PUSH}
{$D-}
    procedure DNRAddrToNameCompletionProc (hip: hostInfoPtr; drp: DNRRecordPtr);
    begin
        drp^.ioResult := hip^.rtnCode;
        if drp^.ioResult = noErr then begin
            BlockMove(@hip^.rtnHostName, @drp^.name, SizeOf(drp^.name));
            SanitizeHostName(drp^.name);
        end;
{    DebugStr(StringOf('DNRAddrToNameCompletionProc ', drp^.ioResult, ' ', drp^.name, ';g'));}
        if drp^.completion <> nil then begin
            CallDNRCompletion(drp, drp^.completion);
        end;
    end;
{$POP}

    procedure DNRAddrToName (addr: longInt; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
        var
            err: OSErr;
    begin
        drp^.ioResult := 1;
        drp^.addr := addr;
        drp^.completion := completion;
        AddrToStr(addr, drp^.name);
        err := AddrToName(addr, drp^.hi, @DNRAddrToNameCompletionProc, ptr(drp));
{    DebugStr(StringOf('DNRAddrToName ', err, ';g'));}
        if err <> cacheFaultErr then begin
            drp^.hi.rtnCode := err;
            DNRAddrToNameCompletionProc(@drp^.hi, drp);
        end;
    end;

end.
dnrptr: ptr;
function TCPNameToAddr (var hostName: str255; timeout: longInt): longInt;
    function TCPOpenResolver (var dataptr: ptr): OSErr;
        function TCPStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
            procedure TCPAddrToStr (dataptr: ptr; addr: longInt; var addrStr: str255);
                function TCPAddrToName (dataptr: ptr; addr: longInt; var rtnStruct: hostInfo; var done: signedByte): OSErr;
                    procedure TCPCloseResolver (dataptr: ptr);
                        function TCPCachedStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
                            procedure TCPSetCache (var hi: hostInfo; host: str255);

                                const
                                    cache_count = 3;
                                var
                                    caches: array[1..cache_count] of hostInfo;
                                    next_cache: integer;

                                function TCPCachedStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
                                    var
                                        i: integer;
                                begin
                                    TCPCachedStrToAddr := noErr;
                                    done := 0;
                                    for i := 1 to cache_count do begin
                                        if (caches[i].rtnCode = noErr) & (IUEqualString(hostName, caches[i].rtnHostName) = 0) then begin
                                            done := 1;
                                            rtnStruct := caches[i];
                                            next_cache := i;
                                            leave;
                                        end;
                                    end;
                                    if done = 0 then begin
                                        TCPCachedStrToAddr := TCPStrToAddr(dataptr, hostName, rtnStruct, done);
                                    end;
                                end;

                                procedure TCPSetCache (var hi: hostInfo; host: str255);
                                begin
                                    if hi.rtnCode = noErr then begin
                                        caches[next_cache] := hi;
                                        caches[next_cache].rtnHostName := host;
                                        next_cache := next_cache mod cache_count + 1;
                                    end;
                                end;
                                for i := 1 to cache_count do begin
                                    caches[i].rtnCode := -1;
                                end;
                                next_cache := 1;